Windows Game Programming for Dummies (2nd Edition)/WinGamProgFD.iso/pc/DirectX SDK/DXSDK/samples/Multimedia/VBSamples/DirectSound/Play3DSound/Sound3D.frm

Visual Basic Form | 2001-10-08 | 15.9 KB | 447 lines

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form DS3DPositionForm
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "DS 3D Positioning"
   ClientHeight    =   5565
   ClientLeft      =   930
   ClientTop       =   330
   ClientWidth     =   5055
   Icon            =   "Sound3D.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5565
   ScaleWidth      =   5055
   Begin VB.Timer tmrUpdate
      Interval        =   50
      Left            =   4260
      Top             =   2100
   End
   Begin MSComDlg.CommonDialog cdlFile
      Left            =   3780
      Top             =   2040
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.PictureBox picDraw
      BackColor       =   &H00FFFFFF&
      FillStyle       =   7  'Diagonal Cross
      Height          =   2775
      Left            =   120
      ScaleHeight     =   181
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   317
      TabIndex        =   7
      TabStop         =   0   'False
      Top             =   2640
      Width           =   4815
   End
   Begin VB.PictureBox picContainer
      Height          =   1755
      Index           =   0
      Left            =   120
      ScaleHeight     =   1695
      ScaleWidth      =   4755
      TabIndex        =   10
      TabStop         =   0   'False
      Top             =   120
      Width           =   4815
      Begin VB.TextBox txtSound
         BackColor       =   &H8000000F&
         Height          =   315
         Left            =   960
         Locked          =   -1  'True
         TabIndex        =   13
         Top             =   120
         Width           =   3735
      End
      Begin VB.CommandButton cmdSound
         Caption         =   "Sound..."
         Enabled         =   0   'False
         Height          =   315
         Left            =   60
         TabIndex        =   0
         Top             =   120
         Width           =   855
      End
      Begin VB.CommandButton cmdPlay
         Caption         =   "Play"
         Height          =   375
         Left            =   120
         TabIndex        =   3
         Top             =   1200
         Width           =   855
      End
      Begin VB.CommandButton cmdPause
         Caption         =   "Pause"
         Height          =   375
         Left            =   1020
         TabIndex        =   4
         Top             =   1200
         Width           =   855
      End
      Begin VB.CommandButton cmdStop
         Caption         =   "Stop"
         Height          =   375
         Left            =   1920
         TabIndex        =   5
         Top             =   1200
         Width           =   735
      End
      Begin VB.CheckBox chLoop
         Caption         =   "Loop Play"
         Height          =   315
         Left            =   2760
         TabIndex        =   6
         Top             =   1260
         Width           =   1455
      End
      Begin VB.HScrollBar scrlVol
         Height          =   255
         LargeChange     =   20
         Left            =   840
         Max             =   0
         Min             =   -3000
         SmallChange     =   500
         TabIndex        =   1
         Top             =   540
         Width           =   3855
      End
      Begin VB.HScrollBar scrlAngle
         Height          =   255
         LargeChange     =   20
         Left            =   840
         Max             =   360
         Min             =   -360
         SmallChange     =   10
         TabIndex        =   2
         Top             =   840
         Value           =   -90
         Width           =   3855
      End
      Begin VB.Label Label1
         BackStyle       =   0  'Transparent
         Caption         =   "Volume"
         Height          =   255
         Index           =   0
         Left            =   120
         TabIndex        =   12
         Top             =   600
         Width           =   1095
      End
      Begin VB.Label Label2
         BackStyle       =   0  'Transparent
         Caption         =   "Direction"
         Height          =   255
         Index           =   0
         Left            =   120
         TabIndex        =   11
         Top             =   900
         Width           =   975
      End
   End
   Begin VB.Label Label5
      BackStyle       =   0  'Transparent
      Caption         =   "Click and drag the red triangle around with the left mouse button to change the sound position."
      Height          =   495
      Left            =   120
      TabIndex        =   9
      Top             =   2160
      Width           =   4755
   End
   Begin VB.Label Label4
      BackStyle       =   0  'Transparent
      Caption         =   "Sound Positions"
      BeginProperty Font
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   120
      TabIndex        =   8
      Top             =   1920
      Width           =   1575
   End
Attribute VB_Name = "DS3DPositionForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  Copyright (C) 1999-2001 Microsoft Corporation.  All Rights Reserved.
'  File:       Sound3d.frm
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'API declare for windows folder
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Dim dx As New DirectX8 'Our DirectX object
Dim ds As DirectSound8 'Our DirectSound object
Dim dsBuffer As DirectSoundSecondaryBuffer8 'Our SoundBuffer
Dim ds3dBuffer As DirectSound3DBuffer8 'We need to get a 3DSoundBuffer
Dim oPos As D3DVECTOR 'Position
Dim fMouseDown As Boolean 'Is the mouse down?
Private Sub cmdSound_Click()
    Static sCurDir As String
    Static lFilter As Long
    Dim dsBuf As DSBUFFERDESC
    'Now we should load a wave file
    'Ask them for a file to load
    With cdlFile
        .flags = cdlOFNFileMustExist Or cdlOFNHideReadOnly
        .FilterIndex = lFilter
        .Filter = "Wave Files (*.wav)|*.wav"
        .FileName = vbNullString
        If sCurDir = vbNullString Then
            'Set the init folder to \windows\media if it exists.  If not, set it to the \windows folder
            Dim sWindir As String
            sWindir = Space$(255)
            If GetWindowsDirectory(sWindir, 255) = 0 Then
                'We couldn't get the windows folder for some reason, use the c:\
                .InitDir = "C:\"
            Else
                Dim sMedia As String
                sWindir = Left$(sWindir, InStr(sWindir, Chr$(0)) - 1)
                If Right$(sWindir, 1) = "\" Then
                    sMedia = sWindir & "Media"
                Else
                    sMedia = sWindir & "\Media"
                End If
                If Dir$(sMedia, vbDirectory) <> vbNullString Then
                    .InitDir = sMedia
                Else
                    .InitDir = sWindir
                End If
            End If
        Else
            .InitDir = sCurDir
        End If
        .ShowOpen   ' Display the Open dialog box
        If .FileName = vbNullString Then
            Exit Sub 'We didn't click anything exit
        End If
        'Save the current information
        sCurDir = GetFolder(.FileName)
        lFilter = .FilterIndex

        'Save the filename for later use
        If Not (dsBuffer Is Nothing) Then dsBuffer.Stop
        Set dsBuffer = Nothing
        txtSound.Text = vbNullString
        dsBuf.lFlags = DSBCAPS_CTRL3D Or DSBCAPS_CTRLVOLUME
        'Before we load the 3D dialog check to see if this is a mono file
        On Error Resume Next
        Set dsBuffer = ds.CreateSoundBufferFromFile(.FileName, dsBuf)
        If Err Then
            'First check to see if this is a stereo wav file
            If (dsBuf.fxFormat.nChannels > 1) And (Err.Number = 5) Then 'Yup
                MsgBox "You must load a mono wave file to control 3D sound.  Stereo wave files are not supported.", vbOKOnly Or vbInformation, "Couldn't load"
            Else
                MsgBox "Could not load this wave file." & vbCrLf & "Format is not supported.", vbOKOnly Or vbInformation, "Couldn't load"
            End If
            Exit Sub
        End If

        'Now we need to get the 3D virtualization params
        Dim f3DParams As New frm3DAlg

        f3DParams.Show vbModal, Me
        If f3DParams.OKHit Then
            If f3DParams.optFull Then dsBuf.guid3DAlgorithm = GUID_DS3DALG_HRTF_FULL
            If f3DParams.optHalf Then dsBuf.guid3DAlgorithm = GUID_DS3DALG_HRTF_LIGHT
            If f3DParams.optNone Then dsBuf.guid3DAlgorithm = GUID_DS3DALG_NO_VIRTUALIZATION
        Else
            Set dsBuffer = Nothing
            Exit Sub
        End If
        On Error Resume Next
        Set dsBuffer = ds.CreateSoundBufferFromFile(.FileName, dsBuf)
        If Err Then
            MsgBox "Could not create the sound buffer.", vbOKOnly Or vbInformation, "Couldn't load"
            Exit Sub
        End If
        txtSound.Text = .FileName
        EnablePlayUI True
        Set ds3dBuffer = dsBuffer.GetDirectSound3DBuffer
        ds3dBuffer.SetConeAngles DS3D_MINCONEANGLE, 100, DS3D_IMMEDIATE
        ds3dBuffer.SetConeOutsideVolume -400, DS3D_IMMEDIATE
        ' position our sound
        ds3dBuffer.SetPosition oPos.x / 50, 0, oPos.z / 50, DS3D_IMMEDIATE
        'Update the volume
        scrlVol_Change
    End With
End Sub
Private Sub Form_Load()
    On Local Error Resume Next
    Set ds = dx.DirectSoundCreate(vbNullString) 'Create a default DirectSound object
    'We couldn't create the DSound object.  End the app now
    If Err.Number <> 0 Then
        MsgBox "Could not initialize DirectSound." & vbCrLf & "This sample will exit.", vbOKOnly Or vbInformation, "Exiting..."
        Unload Me
        End
    End If
    'Set the coop level
    ds.SetCooperativeLevel Me.hWnd, DSSCL_PRIORITY
    'Show the form
    Me.Show
    oPos.x = 0: oPos.z = 5
    '- Make sure we pickup the correct volume and orientation
    scrlAngle_Change
    scrlVol_Change
    DrawPositions
    EnablePlayUI True
    cmdPlay.Enabled = False
    cmdSound.SetFocus
End Sub
Private Sub cmdPlay_Click()
    If dsBuffer Is Nothing Then Exit Sub

    'Play plays the sound from the current position
    'if the sound was paused using the stop command
    'then play will begin where it last left off
    dsBuffer.Play chLoop.Value 'Checked = 1 (looping), Unchecked = 0 (Default)
    EnablePlayUI False
End Sub
Private Sub cmdStop_Click()
    If dsBuffer Is Nothing Then Exit Sub
    dsBuffer.Stop
    dsBuffer.SetCurrentPosition 0 'Reset the position since Stop doesn't
    EnablePlayUI True
End Sub
Private Sub cmdPause_Click()
    If dsBuffer Is Nothing Then Exit Sub
    dsBuffer.Stop 'Stop doesn't reset the position
End Sub
'They've changed the volume.  Update it
Private Sub scrlVol_Change()
    If dsBuffer Is Nothing Then Exit Sub
    dsBuffer.SetVolume scrlVol.Value
End Sub
Private Sub scrlVol_Scroll()
    scrlVol_Change
End Sub
'They've changed the angle.  Update it
Private Sub scrlAngle_Change()
    'We need to calculate a vector of what direction the sound is traveling in.
    Dim x As Single
    Dim z As Single
    'we take the current angle in degrees convert to radians
    'and get the cos or sin to find the direction from an angle
    x = 5 * Cos(3.141 * scrlAngle.Value / 180)
    z = 5 * Sin(3.141 * scrlAngle.Value / 180)
    'Update the UI
    DrawPositions
    If dsBuffer Is Nothing Then Exit Sub
    ds3dBuffer.SetConeOrientation x, 0, z, DS3D_IMMEDIATE
End Sub
Private Sub scrlAngle_Scroll()
    scrlAngle_Change
End Sub
Sub UpdatePosition(x As Single, z As Single)
    On Error Resume Next
    oPos.x = x - picDraw.ScaleWidth / 2
    oPos.z = z - picDraw.ScaleHeight / 2
    DrawPositions
    'the zero at the end indicates we want the postion updated immediately
    If ds3dBuffer Is Nothing Then Exit Sub
    ds3dBuffer.SetPosition oPos.x / 50, 0, oPos.z / 50, DS3D_IMMEDIATE
End Sub
Private Sub picDraw_MouseDown(Button As Integer, Shift As Integer, x As Single, z As Single)
    On Error Resume Next
    If Button = vbLeftButton Then
        UpdatePosition x, z
        fMouseDown = True
    End If
End Sub
Private Sub picDraw_MouseMove(Button As Integer, Shift As Integer, x As Single, z As Single)
    On Error Resume Next
    If Not fMouseDown Then Exit Sub
    If Button = vbLeftButton Then
        'Only update the position if it is outside of the box
        If x < 0 Or z < 0 Or x > picDraw.ScaleWidth Or z > picDraw.ScaleHeight Then Exit Sub
        UpdatePosition x, z
    End If
End Sub
Private Sub picDraw_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
    On Error Resume Next
    fMouseDown = False
End Sub
Private Sub picDraw_Paint()
    DrawPositions
End Sub
Sub DrawPositions()
    Dim x As Integer
    Dim z As Integer
    picDraw.Cls
    'listener is in center and is black
    DrawTriangle 0, picDraw.ScaleWidth / 2, picDraw.ScaleHeight / 2, 90
    'draw sound as RED
    x = CInt(oPos.x) + picDraw.ScaleWidth / 2
    z = CInt(oPos.z) + picDraw.ScaleHeight / 2
    DrawTriangle RGB(256, 0, 0), x, z, scrlAngle.Value
End Sub
'Draw a triangle representing where we are
Sub DrawTriangle(col As Long, x As Integer, z As Integer, ByVal a As Single)
    Dim x1 As Integer
    Dim z1 As Integer
    Dim x2 As Integer
    Dim z2 As Integer
    Dim x3 As Integer
    Dim z3 As Integer
    a = 3.141 * (a - 90) / 180
    Dim q As Integer
    q = 10
    x1 = q * Sin(a) + x
    z1 = q * Cos(a) + z
    x2 = q * Sin(a + 3.141 / 1.3) + x
    z2 = q * Cos(a + 3.141 / 1.3) + z
    x3 = q * Sin(a - 3.141 / 1.3) + x
    z3 = q * Cos(a - 3.141 / 1.3) + z
    picDraw.Line (x1, z1)-(x2, z2), col
    picDraw.Line (x1, z1)-(x3, z3), col
    picDraw.Line (x2, z2)-(x3, z3), col
End Sub
Private Function GetFolder(ByVal sFile As String) As String
    Dim lCount As Long
    For lCount = Len(sFile) To 1 Step -1
        If Mid$(sFile, lCount, 1) = "\" Then
            GetFolder = Left$(sFile, lCount)
            Exit Function
        End If
    Next
    GetFolder = vbNullString
End Function
Private Sub EnablePlayUI(ByVal fEnable As Boolean)
    On Error Resume Next
    If fEnable Then
        chLoop.Enabled = True
        cmdPlay.Enabled = True
        cmdPause.Enabled = False
        cmdStop.Enabled = False
        cmdSound.Enabled = True
        cmdPlay.SetFocus
    Else
        chLoop.Enabled = False
        cmdPlay.Enabled = False
        cmdStop.Enabled = True
        cmdPause.Enabled = True
        cmdSound.Enabled = False
        cmdStop.SetFocus
    End If
End Sub
Private Sub tmrUpdate_Timer()
    If Not (dsBuffer Is Nothing) Then
        If (dsBuffer.GetStatus And DSBSTATUS_PLAYING) <> DSBSTATUS_PLAYING Then
            If cmdPlay.Enabled = False Then
                EnablePlayUI True
            End If
        End If
    End If
End Sub